home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 68.7z / BS1 part 68 / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).7z / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).adf / PC_Tools.LZH / ALISP.ZIP / SKIN.LSP < prev   
Text File  |  1993-10-06  |  16KB  |  337 lines
  1. ;-----------------------------------------------------------------------------+
  2. ;                                                                             |
  3. ;                       SKIN.lsp   Version 1.0   7/5/88                       |
  4. ;                                                                             |
  5. ;                                 Larry Knott                                 |
  6. ;                                                                             |
  7. ;    SKINning is the process of taking an OUTLINE and "pushing" it along a    |
  8. ;    3D curve (or PATH).  This program creates 3DMESH entities as it pushes   |
  9. ;    an OUTLINE along a PATH.  PATHs or OUTLINEs can be defined with the      |
  10. ;    following entities: LINEs, ARCs, PLINEs or 3DPOLYs.                      |
  11. ;                                                                             |
  12. ;    The user has control of the density (or number of SEGMENTs) ALONG and    |
  13. ;    AROUND the SKIN generated by means of the initial prompt:                |
  14. ;                                                                             |
  15. ;         CURRENT SETTINGS:  1.0000 distance along arc per segment,           |
  16. ;         4 segments minimum for 90 degree arc,  12 segments around outline.  |
  17. ;         Do you want to change these settings? <N>: y                        |
  18. ;                                                                             |
  19. ;         >>Distance along arc per segment:                                   |
  20. ;         >>Minimum # segments for 90 deg. arc:                               |
  21. ;         >>Number of segments around outline:                                |
  22. ;                                                                             |
  23. ;      1) The distance along ARC per segment.                                 |
  24. ;            This controls the minimum number of segments generated ALONG     |
  25. ;            ARC segments on the PATH by distance.                            |
  26. ;      2) The minimum number of segments for a 90 degree ARC.                 |
  27. ;            This defines the minimum number of segments to be generated      |
  28. ;            ALONG an ARC segment with a 90 degree included angle.            |
  29. ;      3) The number of segments AROUND the OUTLINE.                          |
  30. ;            The number of segments to generate around the outline as it is   |
  31. ;            pushed along the PATH.                                           |
  32. ;                                                                             |
  33. ;    Useful defaults are provided.  Once values have been defined, or the     |
  34. ;    defaults taken, they are saved for that editing session.  The next       |
  35. ;    prompt is:                                                               |
  36. ;                                                                             |
  37. ;         Select path:                                                        |
  38. ;                                                                             |
  39. ;    This is the PATH that the OUTLINE will be "pushed" along.  Select any    |
  40. ;    LINE, ARC, PLINE or 3DPOLY.  The next prompt is for the OUTLINE.  If     |
  41. ;    an outline has previously been defined in the drawing, the message:      |
  42. ;                                                                             |
  43. ;         >>The outline already exists.  Redefine it? Yes/<No>:               |
  44. ;                                                                             |
  45. ;    is displayed.  If "Yes" is supplied to the above prompt or no outline    |
  46. ;    existed previously, you will be asked:                                   |
  47. ;                                                                             |
  48. ;         Select outline:                                                     |
  49. ;         Insertion base point:                                               |
  50. ;                                                                             |
  51. ;    SKIN will then generate 3DMESHes defined by the PATH and OUTLINE         |
  52. ;    selected.                                                                |
  53. ;                                                                             |
  54. ;                                                                             |
  55. ;    Note:                                                                    |
  56. ;      >  If the PATH contains ARC segments that are "flat" in the currect    |
  57. ;         VPOINT, SKIN may generate the 3DMESH in the wrong direction.        |
  58. ;         Change the vpoint to correct this.                                  |
  59. ;                                                                             |
  60. ;-----------------------------------------------------------------------------+
  61.  
  62. (princ "\nLoading SKIN.lsp...")
  63.  
  64. ;---------------------------- CREATE NEW *ERROR( -----------------------------|
  65.  
  66. (defun skin-er (n)
  67. (command "undo" "end" "undo" "1")
  68. (moder)   ;  UNDO WILL RESTORE SETVARS.
  69. (if (eq n "Function cancelled")
  70.   (princ "\nFunction cancelled by user.  Skin terminated.")
  71.   (princ "\nError: Please report problem to LARRYK on 3mail."))
  72. (setq *error* lisp-er)
  73. (prin1))
  74.  
  75. ;------------------------------- SAVE OLD MODES ------------------------------|
  76.  
  77. (defun getset (a)                                            ;RECURSIVE
  78. (setq mlst '())
  79. (foreach n a
  80.   (setq mlst (append mlst (list (list (car n) (getvar (car n)))))))
  81. (foreach n a (setvar (car n) (cadr n)))
  82. (command "undo" "group")
  83. (setq orgucs (if (> (strlen (getvar "ucsname")) 0) (getvar "ucsname") nil))
  84. (if (or (not orgucs) (eq orgucs "$$skin"))
  85.   (if (tblsearch "ucs" "$$skin")
  86.      (command "ucs" "s" "$$skin" "y")
  87.      (command "ucs" "s" "$$skin")))    ;  EXPERT HAS NO EFFECT ON REDEFINTITION.
  88. )
  89.  
  90. ;----------------------------- RESTORE OLD MODES -----------------------------|
  91.  
  92. (defun moder ()
  93. (command "ucs" "r" (if orgucs orgucs "$$skin"))
  94. (foreach n mlst (setvar (car n) (cadr n))))
  95.  
  96. ;------------------------------ COMMON FUNCTIONS -----------------------------|
  97. ;
  98. ;    REMOVE ENTGET IN GETVAL.  SEND ENTITY LIST AROUND, NOT ENAME.  LESS
  99. ;    OVERHEAD.
  100.  
  101. (defun getval (n e) (cdr (assoc n (entget e))))
  102. (defun 70bit? (n e) (if (zerop (logand n (getval 70 e))) nil T))
  103. (defun midp (l k / ll kk) (mapcar '(lambda (ll kk) (/ (+ ll kk) 2)) l k))
  104.  
  105. ;---------------------------- CHANGE SKIN SETTINGS ---------------------------|
  106. ;
  107. ;    SHOW DEFAULTS, ADD INITGET, MAKE MORE ROBUST.
  108.  
  109. (defun cngset ()
  110. (setq arcdst  (if arcdst arcdst 1.0)
  111.       arcmin  (if arcmin arcmin 16))
  112. (princ (strcat "\n\nCURRENT SETTINGS:  " (rtos arcdst) " distance along arc "
  113.   "per segment,\n" (itoa (/ arcmin 4)) " segments minimum for 90 degree arc,"
  114.   "  " (itoa (getvar "surftab2")) " segments around outline."))
  115. (if (/= (getstring "\nDo you want to change these settings?  Yes/<No>: ") "")
  116.   (progn   (textscr)
  117.   (setq    arcdst    (getreal "\n>>Distance along arc per segment: "))
  118.   (setq    arcmin (* (getint "\n>>Minimum # segments for 90 deg. arc: ") 4))
  119.   (setvar "surftab2" (getint "\n>>Number of segments around outline: ")))))
  120.  
  121. ;--------------------------------- GET ENTITY --------------------------------|
  122.  
  123. (defun getent (t1 t2 retry / e0 e1)
  124. (setq e0 T)
  125. (while e0
  126.   (if (setq e0 (entsel (strcat "\nSelect " t2 ": ")))
  127.     (if (member (cdr (assoc 0 (setq e1 (entget (car e0))))) t1)
  128.       (setq e0 nil)
  129.       (princ (strcat " " (cdr (assoc 0 e1)) ", Not a valid entity.")))
  130.     (setq e0 (if retry (princ "  No entity found.") nil)))
  131. ) (cdr (assoc -1 e1)))                                    ;  SUPPLY ENAME ONLY
  132.  
  133. ;------------------------------ DEFINE OUTLINE -------------------------------|
  134.  
  135. (defun outlin (/ p1 t1 e1)
  136. (setq t1
  137.   (cond
  138.      ((tblsearch "BLOCK" "$$skin")
  139.         (princ "\n>>The outline already exists.  ")
  140.         (initget "Yes No")
  141.         (if (= (getkword "Redefine it?  Yes/<No>: ") "Yes") T nil))
  142.      (T)))
  143. (cond
  144.   (t1 (setq e1 (getent '("POLYLINE" "LINE" "ARC" "CIRCLE") "outline" T))
  145.       (setq p1 (getpoint "\nInsertion base point: "))
  146.       (command "layer" "n" "$$skin" "off" "$$skin" ""
  147.                "copy" e1 "" '(0 0 0) '(0 0 0)
  148.                "chprop" (entlast) "" "la" "$$skin" ""
  149.                "block" "$$skin" p1 (entlast) "")
  150.       (redraw e1))))
  151.  
  152. ;----------------------------- DRAW LINE ROUTINE -----------------------------|
  153. ;
  154. ; BUG IN 2.5 RAMDOM START POINTS FOR TABSURF'S, USE VS RULESURF WHEN FIXED!
  155. ;(command "ucs" "p" "line" p1 p2 ""
  156. ;         "tabsurf"  (list t1 p1) (list (setq t2 (entlast)) p2))
  157.  
  158. (defun drwlin (e / p1 p2 t1 t2) ;  HAVING E1 E2 LOCAL -> LOSE UCS
  159. (setvar "surftab1" (getvar "surftab2"))
  160. (setq p1 (getval 10 e)
  161.       p2 (cond ((getval 11 e))              ;  LINE.
  162.                ((getval 10 (entnext e)))))  ;  POLYLINE.
  163. (if notwcs (setq p1 (trans p1 path 1)
  164.                  p2 (trans p2 path 1)))
  165. (command "ucs" "za" p1 p2                   ;  RANDOM XY PLANE. CHANGE
  166.          "insert" "*$$skin" '(0 0 0) 1 0)
  167. (setq t1 (entlast))                         ;  WATCH DIST. BUG.
  168. (command "insert" "*$$skin" (list 0 0 (distance p1 p2)) 1 0
  169.          "ucs" "p"
  170.          "rulesurf" (list t1 p1) (list (setq t2 (entlast)) p2))
  171. (entdel t1) (entdel t2))
  172.  
  173. ;------------------------------ DRAW ARC ROUTINE -----------------------------|
  174. ;
  175. ;    WHEN THE CURRENT VIEWDIR IS PARALELL TO THE AXIS OF REVOLUTION, THE
  176. ;    REVSURF OR TABSURF RESULTS ARE NOT CONSISTANT. CHANGE VPOINT.
  177.  
  178. (defun drwarc (e)
  179. (setq c1 (getval 10 e)
  180.       c2 (mapcar '+ c1 '(0 0 1))
  181.       r1 (getval 40 e)
  182.       a1 (getval 50 e)
  183.       a2 (getval 51 e)
  184.       ia (abs (if (> a1 a2) (- a1 (* pi 2) a2) (- a2 a1)))  ;  NEEDS REFINEMENT.
  185. ;       p1 (polar c1 a1 r1)     BUG- POLAR OF 3D SHOULD RETURN 3D PT.
  186. ;       p2 (polar c1 a2 r1)
  187.       p1 (append (polar c1 a1 r1) '(0))
  188.       p2 (append (polar c1 a2 r1) '(0)))
  189. (setvar "surftab1" (abs (fix (if (> (fix (/ (* 2 pi r1) arcdst)) arcmin)
  190.   (/ (* ia r1) arcdst) (* arcmin (/ ia pi))))))
  191. (setq p1 (trans p1 e 1)
  192.       p2 (trans p2 e 1)
  193.       c1 (trans c1 e 1)
  194.       c2 (trans c2 e 1))
  195. (command "ucs" "3p" p1 c1 c2
  196.          "insert" "*$$skin" '(0 0 0) 1 0
  197.          "ucs" "p")
  198. (setq e1 (entlast))
  199. (command "line" c1 c2 ""
  200.          "revsurf" (list e1 p1)
  201.            (list (setq e2 (entlast)) (getval 10 e2)) 0 ia)
  202. (entdel e1) (entdel e2))
  203.  
  204. ;----------------------------- DRAW PLINE ROUTINE ----------------------------|
  205. ;
  206. ;    SELECTION OF AXIS FOR REVSURF ON END (IE NORNAL) RESULTS IN INCONSISTANT
  207. ;    RESULTS.    ENTSEL LISTS ACT STRANGE.     SEE ALSO DRWARC.  NEED TO HANDLE
  208. ;    CLOSED PLINES.    AS WELL AS KEEP X-AXIS ALIGNED SUCH AS UCSXAXIS.
  209.  
  210. (defun drwpli (e / e1)
  211. (while (/= (getval 0 (entnext e)) "SEQEND")
  212.   (cond
  213.      ((zerop (getval 42 e))  (drwlin e))          ;     LINE SEGMENT?
  214.      (T (setq e1 e                                ;     ARC SEGMENT.
  215.               e2 (entnext e1)
  216.               p1 (getval 10 e1)                   ;     POINT 1
  217.               p2 (getval 10 e2)                   ;     POINT 2
  218.               b1 (getval 42 e1)                   ;     BULGE
  219.               a1 (angle p1 p2)                    ;     ANGLE BETWEEN P1 & P2
  220.               d1 (distance p1 p2)                 ;     DISTANCE BETWEEN P1 & P2
  221.               ia (* 4 (atan b1))                  ;     INCLUDED ANGLE
  222.               r1 (/ (/ d1 2) (sin (/ ia 2)))      ;     RADIUS
  223.               ;  BUG POLAR 3D PT. SHOULD RETURN 3D POINT.
  224.               c1 (append (polar p1 (+ a1 (- (/ pi 2) (/ ia 2))) r1)
  225.                          (list (caddr p1)))       ;     center point
  226.               c2 (mapcar '+ c1 '(0 0 -1)))
  227.         (setvar "surftab1" (abs (fix (if (> (fix (/ (* 2 pi r1) arcdst)) arcmin)
  228.                                        (/ (* ia r1) arcdst)
  229.                                        (* arcmin (/ ia pi))))))
  230.         (setq p1 (trans p1 path 0)
  231.               p2 (trans p2 path 0)
  232.               c1 (trans c1 path 0)
  233.               c2 (trans c2 path 0))
  234.         (command "ucs" "3p" p1 c1 c2
  235.                  "insert" "*$$skin" '(0 0 0) 1 0
  236.                  "ucs" "p")
  237.         (setq e1 (entlast))
  238.         (command "color" "1" "line" c1 c2 "" "color" "bylayer"
  239.                  "revsurf" (list e1 p1)
  240.                     (list (setq e2 (entlast)) c1) 0 (- ia))
  241.         (entdel e1) (entdel e2)
  242.      ))
  243. ; (while (/= (setq temp (getstring "\nVariable to test: ")) "")
  244. ;    (princ (strcat temp ": "))
  245. ;    (princ (eval (read temp)))
  246. ;    (command "line" (eval (read temp)) pause ""))
  247.   (setq e (entnext e)))
  248. ;    SLOW SSGET FILTERS.  DEL SOME OTHER WAY.
  249. (if (ssget "x" '((8 . "$$skin"))) (command "erase" "p" ""))
  250. )
  251.  
  252. ;--------------------------- DRAW SPLINE-FIT PLINE ---------------------------|
  253. ;
  254. ;    WORKS IN WCS POINTS.
  255.  
  256. (defun splseg ()
  257. (command "ucs" "za" (midp p1 p2) p2
  258.                "insert" "*$$skin" '(0 0 0) 1 0
  259.                "ucs" "p"
  260.                "rulesurf"
  261.                   (list e2 '(0 0 0))
  262.                   (list (setq e3 (entlast)) '(0 0 0)))
  263. (entdel e2)
  264. (setq p0 p1
  265.       p1 p2
  266.       e2 e3))
  267.  
  268. (defun drwspl (e / e1 e2 e3 p0 p1 p2)
  269. (setvar "surftab1" (getvar "surftab2"))
  270. (setq e1 (entnext e)  ;  FIRST POINT ALLWAYS CONTROL
  271.       p1 (TRANS (getval 10 e1) PATH 0)
  272.       p2 (TRANS (getval 10 (setq e1 (entnext e1))) PATH 0))
  273. (command "ucs" "za" (midp p1 p2) p2
  274.          "insert" "*$$skin" '(0 0 0) 1 0
  275.          "ucs" "p")
  276. (setq e2 (entlast))
  277. (if closed
  278.   (setq s1 (list p1 p2))
  279.   (command "copy" e2 "" p2 (midp p1 p2)  ;  DO FIRST SEGMENT.
  280.            "rulesurf"
  281.               (list e2 '(0 0 0))
  282.               (list (setq e3 (entlast)) '(0 0 0))))
  283. (if e3 (entdel e3))
  284. (setq p1 p2)
  285. (while p2
  286.   (setq p2 (TRANS (getval 10 (setq e1 (entnext e1))) PATH 0))
  287.   (if (70bit? 16 e1) (setq p2 nil) (splseg))  ;  SPLINE FRAME CONTROL PT?
  288. )
  289. (if closed
  290.   (progn
  291.      (setq p2 (car s1))
  292.      (splseg)
  293.      (setq p2 (cadr s1))
  294.      (entdel (splseg)))
  295.   (command "copy" e3 "" (midp p0 p1) p1 ;  DO LAST SEGMENT.
  296.            "rulesurf"
  297.               (list e2 '(0 0 0))
  298.               (list (setq e3 (entlast)) '(0 0 0))))
  299. (entdel e3) (entdel e2))
  300.  
  301. ;-------------------------------- MAIN PROGRAM -------------------------------|
  302.  
  303. (defun c:skin ();/ path patype notwcs outl closed)
  304. (setq lisp-er *error*
  305.       *error* skin-er)
  306. (getset '(          ("ucsfollow"  0)  ("regenmode"  0)  ("expert"    2)
  307.   ("cmdecho"    0)  ("snapmode"   0)  ("gridmode"   0)  ("blipmode"  1)
  308.   ("highlight"  0)  ("aunits"     3)  ("ucsicon"    1)  ("flatland"  0)))
  309. (cngset)
  310. (cond
  311.   ((setq path (getent '("POLYLINE" "LINE" "ARC") "path" nil))
  312.      (setq patype   (getval 0 path)
  313.            notwcs   (cond ((getval 210 path)) (T nil))
  314.            outl     (outlin))
  315.      (setvar "blipmode" 0) (command "ucs" "w")
  316.      (cond
  317.         ((eq patype      "ARC")    (drwarc path))
  318.         ((eq patype     "LINE")    (drwlin path))
  319.         ((eq patype "POLYLINE")                   ;  THEN SEND FIRST VERTEX.
  320.            (setq closed (if (70bit? 1 path) T nil))
  321.            (cond
  322.               ((70bit? 16 path) (princ "\nCannot SKIN a 3DMESH."))
  323.               ((70bit? 4  path) (drwspl (entnext path)))
  324.               (T                (drwpli (entnext path)))))
  325.         (T (princ "\nNot a defined POLYLINE TYPE."))))
  326.   (T (princ "\nNo object found.")))
  327. (command "undo" "end")
  328. (moder)
  329. (setq *error* lisp-er)
  330. (if path (princ "\nProcess complete.") (princ "  Process terminated."))
  331. (prin1))
  332.  
  333. ;------------------------------------ END ------------------------------------|
  334.  
  335. (princ "Loaded. \n")
  336. (prin1)
  337.